home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / ADA / GNAT / !gcc / adainc / 3 / adb / i-cpoint < prev    next >
Text File  |  1996-02-12  |  8KB  |  283 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --                I N T E R F A C E S . C . P O I N T E R S                 --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.9 $                              --
  10. --                                                                          --
  11. --     Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc.     --
  12. --                                                                          --
  13. -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14. -- terms of the  GNU General Public License as published  by the Free Soft- --
  15. -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16. -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17. -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18. -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19. -- for  more details.  You should have  received  a copy of the GNU General --
  20. -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21. -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22. -- MA 02111-1307, USA.                                                      --
  23. --                                                                          --
  24. -- As a special exception,  if other files  instantiate  generics from this --
  25. -- unit, or you link  this unit with other files  to produce an executable, --
  26. -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27. -- covered  by the  GNU  General  Public  License.  This exception does not --
  28. -- however invalidate  any other reasons why  the executable file  might be --
  29. -- covered by the  GNU Public License.                                      --
  30. --                                                                          --
  31. -- GNAT was originally developed  by the GNAT team at  New York University. --
  32. -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  33. --                                                                          --
  34. ------------------------------------------------------------------------------
  35.  
  36. with Interfaces.C.Strings; use Interfaces.C.Strings;
  37. with System;               use System;
  38.  
  39. with Unchecked_Conversion;
  40.  
  41. package body Interfaces.C.Pointers is
  42.  
  43.    type Addr is mod Memory_Size;
  44.  
  45.    function To_Pointer is new Unchecked_Conversion (Addr,      Pointer);
  46.    function To_Addr    is new Unchecked_Conversion (Pointer,   Addr);
  47.    function To_Addr    is new Unchecked_Conversion (ptrdiff_t, Addr);
  48.    function To_Ptrdiff is new Unchecked_Conversion (Addr,      ptrdiff_t);
  49.  
  50.    Elmt_Size : ptrdiff_t :=
  51.                  (Element'Size + Storage_Unit - 1) / Storage_Unit;
  52.  
  53.    subtype Index_Base is Index'Base;
  54.  
  55.    ---------
  56.    -- "+" --
  57.    ---------
  58.  
  59.    function "+" (Left : in Pointer;   Right : in ptrdiff_t) return Pointer is
  60.    begin
  61.       if Left = null then
  62.          raise Pointer_Error;
  63.       end if;
  64.  
  65.       return To_Pointer (To_Addr (Left) + To_Addr (Elmt_Size * Right));
  66.    end "+";
  67.  
  68.    function "+" (Left : in ptrdiff_t; Right : in Pointer) return Pointer is
  69.    begin
  70.       if Right = null then
  71.          raise Pointer_Error;
  72.       end if;
  73.  
  74.       return To_Pointer (To_Addr (Elmt_Size * Left) + To_Addr (Right));
  75.    end "+";
  76.  
  77.    ---------
  78.    -- "-" --
  79.    ---------
  80.  
  81.    function "-" (Left : in Pointer; Right : in ptrdiff_t) return Pointer is
  82.    begin
  83.       if Left = null then
  84.          raise Pointer_Error;
  85.       end if;
  86.  
  87.       return To_Pointer (To_Addr (Left) - To_Addr (Right * Elmt_Size));
  88.    end "-";
  89.  
  90.  
  91.    function "-" (Left : in Pointer; Right : in Pointer) return ptrdiff_t is
  92.    begin
  93.       if Left = null or else Right = null then
  94.          raise Pointer_Error;
  95.       end if;
  96.  
  97.       return To_Ptrdiff (To_Addr (Left) - To_Addr (Right)) / Elmt_Size;
  98.    end "-";
  99.  
  100.    ----------------
  101.    -- Copy_Array --
  102.    ----------------
  103.  
  104.    procedure Copy_Array
  105.      (Source  : in Pointer;
  106.       Target  : in Pointer;
  107.       Length  : in ptrdiff_t)
  108.    is
  109.       T : Pointer := Target;
  110.       S : Pointer := Source;
  111.  
  112.    begin
  113.       if S = null or else T = null then
  114.          raise Dereference_Error;
  115.  
  116.       else
  117.          for J in 1 .. Length loop
  118.             T.all := S.all;
  119.             Increment (T);
  120.             Increment (S);
  121.          end loop;
  122.       end if;
  123.    end Copy_Array;
  124.  
  125.    ---------------------------
  126.    -- Copy_Terminated_Array --
  127.    ---------------------------
  128.  
  129.    procedure Copy_Terminated_Array
  130.      (Source     : in Pointer;
  131.       Target     : in Pointer;
  132.       Limit      : in ptrdiff_t := ptrdiff_t'Last;
  133.       Terminator : in Element := Default_Terminator)
  134.    is
  135.       S : Pointer   := Source;
  136.       T : Pointer   := Target;
  137.       L : ptrdiff_t := Limit;
  138.  
  139.    begin
  140.       if S = null or else T = null then
  141.          raise Dereference_Error;
  142.  
  143.       else
  144.          while S.all /= Terminator and then L > 0 loop
  145.             T.all := S.all;
  146.             Increment (T);
  147.             Increment (S);
  148.             L := L - 1;
  149.          end loop;
  150.       end if;
  151.    end Copy_Terminated_Array;
  152.  
  153.    ---------------
  154.    -- Decrement --
  155.    ---------------
  156.  
  157.    procedure Decrement (Ref : in out Pointer) is
  158.    begin
  159.       Ref := Ref - 1;
  160.    end Decrement;
  161.  
  162.    ---------------
  163.    -- Increment --
  164.    ---------------
  165.  
  166.    procedure Increment (Ref : in out Pointer) is
  167.    begin
  168.       Ref := Ref + 1;
  169.    end Increment;
  170.  
  171.    -----------
  172.    -- Value --
  173.    -----------
  174.  
  175.    function Value
  176.      (Ref        : in Pointer;
  177.       Terminator : in Element := Default_Terminator)
  178.       return       Element_Array
  179.    is
  180.       P : Pointer;
  181.       L : constant Index_Base := Index'First;
  182.       H : Index_Base;
  183.  
  184.    begin
  185.       if Ref = null then
  186.          raise Dereference_Error;
  187.  
  188.       else
  189.          H := L;
  190.          P := Ref;
  191.  
  192.          loop
  193.             exit when P.all = Terminator;
  194.             H := Index_Base'Succ (H);
  195.             Increment (P);
  196.          end loop;
  197.  
  198.          declare
  199.             subtype A is Element_Array (L .. H);
  200.  
  201.             type PA is access A;
  202.             function To_PA is new Unchecked_Conversion (Pointer, PA);
  203.  
  204.          begin
  205.             return To_PA (Ref).all;
  206.          end;
  207.       end if;
  208.    end Value;
  209.  
  210.    function Value
  211.      (Ref    : in Pointer;
  212.       Length : in ptrdiff_t)
  213.       return   Element_Array
  214.    is
  215.       P : Pointer;
  216.       L : Index_Base;
  217.       H : Index_Base;
  218.  
  219.    begin
  220.       if Ref = null then
  221.          raise Dereference_Error;
  222.  
  223.       --  For length zero, we need to returna null slice, but we can't make
  224.       --  the bounds of this slice Index'First, since this could cause a
  225.       --  Constraint_Error if Index'First = Index'Base'First.
  226.  
  227.       elsif Length <= 0 then
  228.          declare
  229.             X : Element_Array (Index'Succ (Index'First) .. Index'First);
  230.  
  231.          begin
  232.             return X;
  233.          end;
  234.  
  235.       --  Normal case (length non-zero)
  236.  
  237.       else
  238.          L := Index'First;
  239.          H := Index'Val (Index'Pos (Index'First) + Length - 1);
  240.  
  241.          declare
  242.             subtype A is Element_Array (L .. H);
  243.  
  244.             type PA is access A;
  245.             function To_PA is new Unchecked_Conversion (Pointer, PA);
  246.  
  247.          begin
  248.             return To_PA (Ref).all;
  249.          end;
  250.       end if;
  251.    end Value;
  252.  
  253.    --------------------
  254.    -- Virtual_Length --
  255.    --------------------
  256.  
  257.    function Virtual_Length
  258.      (Ref        : in Pointer;
  259.       Terminator : in Element := Default_Terminator)
  260.       return       ptrdiff_t
  261.    is
  262.       P : Pointer;
  263.       C : ptrdiff_t;
  264.  
  265.    begin
  266.       if Ref = null then
  267.          raise Dereference_Error;
  268.  
  269.       else
  270.          C := 0;
  271.          P := Ref;
  272.  
  273.          while P.all /= Terminator loop
  274.             C := C + 1;
  275.             Increment (P);
  276.          end loop;
  277.  
  278.          return C;
  279.       end if;
  280.    end Virtual_Length;
  281.  
  282. end Interfaces.C.Pointers;
  283.